home *** CD-ROM | disk | FTP | other *** search
/ Delphi Magazine Collection 2001 / Delphi Magazine Collection 20001 (2001).iso / DISKS / ISSUE08 / MODEL / STRLIB.PAS < prev   
Encoding:
Pascal/Delphi Source File  |  1996-01-06  |  13.7 KB  |  509 lines
  1. {*******************************************************
  2.                 TNodes [Nodes unit]
  3.  
  4. This unit contains the a number of string manipulation routines
  5. most of which came from Niel Rubenking's Turbo Pascal 6.0
  6. Techniques and Utilities. Probably the best book on Pascal
  7. programming I have.
  8.  
  9. Other routines I wrote myself and one or two come from sources
  10. I have long since forgotten. I apologize to Niel Rubenking and
  11. anyone else who may find a routine they wrote in this library
  12. for not indicating which is which. However, I just can't
  13. remember. I do know the they were all in the public domain
  14. though so I figure its alright this way.
  15.  
  16.                 Paul Warren
  17.        HomeGrown Software Development
  18.      (c) 1995 Langley British Columbia.
  19.               (604) 530-9097
  20.        e-mail:  hg_soft@uniserve.com
  21.   Home page: http://haven.uniserve.com/~hg_soft
  22.  
  23. ********************************************************}
  24.  
  25. unit StrLib;
  26.  
  27. interface
  28.  
  29. uses SysUtils, Graphics;
  30.  
  31. type
  32.   Justification = (jLeft, jRight, jCenter);
  33.  
  34. function UpperCase(S : string) : string;
  35. function Dupe(C : Char; Len : Byte) : string;
  36. function ADupe(C : Char; Len : Byte) : string;
  37. function Pad(S : string; C : Char; Len : Byte) : string;
  38. function APad(S : string; C : Char; Len : Byte) : string;
  39. function LeftPad(S : string; C : Char; Len : Byte) : string;
  40. function ALeftPad(S : string; C : Char; Len : Byte) : string;
  41. function Chop(S : string; len: Byte): string;
  42. procedure RChop(var S: string; len: Byte);
  43. function AChop(S : string; len: Byte): string;
  44. function LeftChop(S : string; len: Byte): string;
  45. function LeftChopBy(S : string; len: Byte): string;
  46. procedure LChop(var S: string; len: Byte);
  47. procedure LChopBy(var S: string; len: Byte);
  48. function ALeftChop(S : string; len: Byte): string;
  49. procedure Trim(var S : string; C : Char);
  50. procedure TrimTo(var S : string; C : Char);
  51. procedure TrimLead(var S : string; C : Char);
  52. function LRTrim(S: string): string;
  53. function NumLong(L: LongInt): string;
  54. function RealToStr(R: real; NumDec: byte): string;
  55. function StrTOReal(var code: integer; S: string): real;
  56. procedure Replace(NewString, OldString: string; var MainString: string);
  57. procedure InsertAfter(NewString, AnchorString: string;
  58.              var MainString: string; Spacer: byte);
  59. procedure CopyInto(const InStr: string; Column: Byte; var OutStr: string);
  60. function SubStr(S: string; BegChar, EndChar: char): string;
  61. function JustifyStr(var S: string; L: byte; Just: Justification): string;
  62. function StrToMask ( S : string; Mask : string ) : string;
  63. function StripMask ( S : string ) : string;
  64. function MinimizeName(const Filename: TFileName; Canvas: TCanvas;
  65.   MaxLen: Integer): TFileName;
  66.  
  67. implementation
  68.  
  69. function UpperCase(S: string): string;
  70. var P: Byte;
  71. begin
  72.   for P := 1 to length(S) do
  73.     S[P] := UpCase(S[P]);
  74.   UpperCase := S;
  75. end;
  76.  
  77. function Dupe(C: Char; Len: Byte): string;
  78. var Temp: string;
  79. begin
  80.   FillChar(Temp[1], Len, C);
  81.   Temp[0] := Char(Len);
  82.   Dupe := Temp;
  83. end;
  84.  
  85. function ADupe(C : Char; Len : Byte): string; Assembler;
  86. ASM
  87.   LES DI, @Result
  88.   CLD
  89.   XOR CH, CH
  90.   MOV CL, Len       {length in CX}
  91.   MOV AX, CX        {and in AX}
  92.   STOSB             {store length byte}
  93.   MOV AL, C
  94.   REP STOSB         {fill string with char}
  95. end;
  96.  
  97. function Pad(S : string; C : Char; Len : Byte) : string;
  98. begin
  99.   IF length(S) < len then
  100.     FillChar(S[succ(length(S))], Len-length(S), C);
  101.   S[0] := char(Len);
  102.   Pad := S;
  103. end;
  104.  
  105. function APad(S: string; C: Char; Len: Byte): string; Assembler;
  106. ASM
  107.   PUSH DS
  108.   LDS SI, S        {DS:SI points to S}
  109.   LES DI, @Result  {ES:DI points to result}
  110.   LODSB            {read existing length}
  111.   XOR AH, AH
  112.   MOV CX, AX
  113.   MOV AL, Len      {Set result to desired length}
  114.   STOSB            {Transfer length to result}
  115.   MOV BX, CX
  116.   REP MOVSB        {Now S is in @Result}
  117.   XOR CH, CH
  118.   MOV CL, Len      {Get desired length in CX}
  119.   SUB CX, BX       {Subtract current length}
  120.   JLE @NoPad       {If difference < 0, no pad}
  121.   MOV AL, C      {Put char in AL}
  122.     REP STOSB      {Fill rest of string}
  123.   @NoPad:
  124.   POP DS
  125. end;
  126.  
  127. function LeftPad(S: string; C: Char; Len: Byte): string;
  128. begin
  129.   IF length(S) < Len then
  130.     begin
  131.       MOVE(S[1], S[succ(Len - length(S))], length(S));
  132.       FillChar(S[1], Len - length(S), C);
  133.     end;
  134.   S[0] := Char(Len);
  135.   LeftPad := S;
  136. end;
  137.  
  138. function ALeftPad(S: string; C: Char; Len: Byte): string; Assembler;
  139. ASM
  140.   PUSH DS
  141.   CLD
  142.   LES DI, @Result  {ES:DI points to result}
  143.   MOV AL, Len
  144.   XOR AH, AH
  145.   MOV CX, AX       {Desired length in CX}
  146.   STOSB            {length byte of result}
  147.   LDS SI, S        {DS:SI points to S}
  148.   LODSB            {AL has length of S}
  149.   MOV BL, AL       {remember length of S}
  150.   SUB CX, AX       {subtract actual from desired}
  151.   JLE @NoPad       {if diff < 0, don't pad}
  152.     MOV AL, C      {fill at start of string}
  153.     REP STOSB
  154.   @NoPad:
  155.   MOV CL, BL       {get back length of S}
  156.   REP MOVSB        {copy rest of S}
  157.   POP DS
  158. end;
  159.  
  160. function Chop(S: string; len: Byte): string;
  161. begin
  162.   if length(S) > len then
  163.     S[0] := Char(Len);
  164.   Chop := S;
  165. end;
  166.  
  167. procedure RChop(var S: string; len: Byte);
  168. begin
  169.   if length(S) > len then
  170.     S[0] := Char(Len);
  171. end;
  172.  
  173. function AChop(S: string; len: Byte): string; Assembler;
  174. ASM
  175.   PUSH DS
  176.   LDS SI, S
  177.   LES DI, @Result
  178.   LODSB
  179.   XOR AH, AH
  180.   XCHG AX, CX
  181.   CMP CL, Len       {if length > len,...}
  182.   JB @NoChop
  183.     MOV CL, Len     {... set length to len}
  184.   @NoCHop:
  185.   MOV AL, CL        {store length}
  186.   STOSB
  187.   REP MOVSB         {copy Len chars to result}
  188.   POP DS
  189. end;
  190.  
  191. function LeftChop(S: string; len: Byte): string;
  192. begin
  193.   if length(S) > len then
  194.     begin
  195.       MOVE(S[succ(length(S) - len)],
  196.            S[1], Len);
  197.       S[0] := Char(Len);
  198.     end;
  199.   LeftChop := S;
  200. end;
  201.  
  202. function LeftChopBy(S: string; len: Byte): string;
  203. begin
  204.   IF length(S) > len then
  205.     begin
  206.       MOVE(S[succ(len)],
  207.            S[1], Length(S)-Len);
  208.       S[0] := Char(Length(S)-Len);
  209.     end else S[0] := #0;
  210.   LeftChopBy := S;
  211. end;
  212.  
  213. procedure LChop(var S : string; len: Byte);
  214. begin
  215.   IF length(S) > len then
  216.     begin
  217.       MOVE(S[succ(length(S) - len)],
  218.            S[1], Len);
  219.       S[0] := Char(Len);
  220.     end;
  221. end;
  222.  
  223. procedure LChopBy(var S : string; len: Byte);
  224. begin
  225.   IF length(S) > len then
  226.     begin
  227.       MOVE(S[succ(len)], S[1], Length(S)-len);
  228.       S[0] := Char(Length(S)-len);
  229.     end;
  230. end;
  231.  
  232. function ALeftChop(S: string; len: Byte): string; Assembler;
  233. ASM
  234.   PUSH DS
  235.   LDS SI, S
  236.   LES DI, @Result
  237.   LODSB
  238.   XOR AH, AH
  239.   XCHG AX, CX
  240.   CMP CL, Len       {if length > len,...}
  241.   JB @NoChop
  242.     ADD SI, CX      {point to end of string}
  243.     MOV CL, Len     {set length to len}
  244.     SUB SI, CX      {point to new start of string}
  245.   @NoCHop:
  246.   MOV AL, CL        {store length}
  247.   STOSB
  248.   REP MOVSB         {copy Len chars to result}
  249.   POP DS
  250. end;
  251.  
  252. procedure Trim(var S : string; C : Char);
  253. begin
  254.   while S[length(S)] = C do Dec(S[0]);
  255. end;
  256.  
  257. procedure TrimTo(var S : string; C : Char);
  258. begin
  259.   if Pos(C, S) <> 0 then LeftChop(S, Pos(C, S));
  260. end;
  261.  
  262. procedure TrimLead(var S : string; C : Char);
  263. var P : Byte;
  264. begin
  265.   P := 1;
  266.   while (S[P] = C) and (P <= length(S)) do Inc(P);
  267.   case P of
  268.     0 : S[0] := #0; {string was 255 of C!}
  269.     1 : ; {not found}
  270.     else
  271.       Move(S[P], S[1], succ(length(S) - P));
  272.       Dec(S[0], pred(P));
  273.   end;
  274. end;
  275.  
  276. function LRTrim(S: string): string; assembler;
  277. asm
  278.   mov   bx, ds                    { save data segment                   }
  279.   push  es
  280.   lds   si, S                     { load source register with S         }
  281.   les   di, @result               { load destination register           }
  282.   mov   cl, ds:[si]               { move length of S into cx            }
  283.   or    cl, cl                    { is it a zero?                       }
  284.   jz    @AssignNullString
  285.   xor   ch, ch                    { we only want the low byte           }
  286.   mov   al, ' '                   { store space in AL                   }
  287. @IsSpace:
  288.   inc   si
  289.   cmp   ds:[si], al
  290.   loope @IsSpace                  { keep looping until it's not a blank }
  291.   or    cl, cl
  292.   jnz   @NotBlankString
  293.   cmp   ds:[si], al               { last character could be a non-blank }
  294.   je    @AssignNullString
  295. @NotBlankString:
  296.   inc   cl
  297.   inc   di
  298.   mov   dl, cl                    { store CL in DL                      }
  299.   cld                             { we are moving forward               }
  300.   repnz movsb                     { add string S to trimmed string      }
  301.   dec   di
  302.   mov   cl, dl
  303.   std
  304.   repe  scasb                     { while = to blank space              }
  305.   inc   cl
  306.   les   di, @result               { load destination register           }
  307. @AssignNullString:
  308.   mov   es:[di], cl               { move new length to trimmed string   }
  309.   pop   es
  310.   mov   ds, bx                    { restore                             }
  311. end ;
  312.  
  313. function NumLong(L: LongInt): string;
  314. var
  315.   temp: string;
  316. begin
  317.   Str(L, temp);
  318.   NumLong := temp;
  319. end;
  320.  
  321. function StrToReal(var code: integer; S: string): real;
  322. var
  323.   V: real;
  324.   {code: integer;}
  325. begin
  326.   Val(S, V, code);
  327.   StrToReal := V;
  328. end;
  329.  
  330. function RealToStr(R: real; NumDec: byte): string;
  331. var
  332.   temp: string;
  333. begin
  334.   Str(R:0:NumDec, temp);
  335.   RealToStr := temp;
  336. end;
  337.  
  338. procedure Replace(NewString, OldString: string; var MainString: string);
  339. begin
  340.   Insert(NewString, MainString, Pos(OldString, MainString));
  341.   Delete(MainString, Pos(OldString, MainString), Length(OldString));
  342. end;
  343.  
  344. procedure InsertAfter(NewString, AnchorString: string;
  345.              var MainString: string; Spacer: byte);
  346. begin
  347.   Insert(NewString, MainString, Pos(AnchorString, MainString)+Spacer);
  348.   Delete(MainString, Pos(AnchorString, MainString)+Length(NewString)+Spacer, Length(NewString));
  349. end;
  350.  
  351. {*
  352. * Name       : CopyInto
  353. * Purpose    : Copy InStr into OutStr at column Col.
  354. * Parameters : InStr - the string to be inserted
  355. *              Col   - where to insert
  356. *              OutStr- the string to insert into, and result
  357. * Notes      : This routine is great for for creating formated output.
  358. *              This is not just another INSERT. It does not move any chars
  359. *              like insert, it just overwrites the existing string. Will
  360. *              not copy beyond the end of the Destination string.
  361. *              Basically, you just make a string of all blanks the desired
  362. *              length, then copy other strings into it at fixed columns.
  363. *}
  364. Procedure CopyInto(const InStr: string; Column: Byte; var OutStr: string);
  365. begin
  366.   if (Byte(InStr[0]) <> 0) then
  367.   begin
  368.     if (Column > Byte(OutStr[0])) then
  369.       Exit
  370.     else if (Column + Byte(InStr[0]) - 1 > Byte(OutStr[0])) then
  371.       Move(InStr[1], OutStr[Column], Byte(OutStr[0]) - Column + 1)
  372.     else
  373.       Move(InStr[1], OutStr[Column], Byte(InStr[0]));
  374.   end;
  375. end;
  376.  
  377. function FCopyInto(const InStr: string; Column: Byte; OutStr: string): string;
  378. begin
  379.   CopyInto(InStr, Column, OutStr);
  380.   FCopyInto := OutStr;
  381. end;
  382.  
  383. function SubStr(S: string; BegChar, EndChar: char): string;
  384. begin
  385.   SubStr := Copy(S, Pos(BegChar, S), Pos(EndChar, S)-Pos(BegChar, S)+1);
  386. end;
  387.  
  388. function JustifyStr(var S: string; L: byte; Just: Justification): string;
  389. var
  390.   i: integer;
  391. begin
  392.   if Length(S) > L then byte(S[0]) := L;
  393.   case Just of
  394.     jLeft: S := Pad(S, ' ', L);
  395.     jRight: S := LeftPad(S, ' ', L);
  396.     jCenter: S := LeftPad(S, ' ', (L div 2)-(Length(S) div 2));
  397.   end;
  398.   JustifyStr := S;
  399. end;
  400.  
  401. function StrToMask(S: string; Mask: string): string;
  402. var
  403.   i: integer;
  404.   Negative: boolean;
  405. begin
  406.   S := LRTrim (S);
  407.   Negative := S[1] = '-';
  408.   if Negative then
  409.      S := copy(S, 2, length(S));
  410.  
  411.   { add commas }
  412.   if pos(',', Mask) <> 0 then
  413.      begin
  414.      { calc first comma pos }
  415.      i := pos('.', S );
  416.      if i = 0 then
  417.        i := length(S) - 2
  418.      else
  419.        dec(i, 3);
  420.      while i > 1 do
  421.      begin
  422.        Insert(',', S, i);
  423.        dec (i, 3);
  424.      end;
  425.    end;
  426.  
  427.     { add a dollar sign }
  428.   if pos ('$', Mask) <> 0 then
  429.      S := '$' + S;
  430.  
  431.     { add a percent sign }
  432.   if pos ('%', Mask) <> 0 then
  433.      S := S + '%';
  434.  
  435.     { add a minus sign }
  436.   if Negative then
  437.      S := '-' + S;
  438.  
  439.   StrToMask := LeftPad(S, ' ',length(Mask));
  440. end;
  441.  
  442. function StripMask (S: string ): string;
  443. const
  444.   ValidChars = ['0'..'9', '.', '-'];
  445. var
  446.   St: string;
  447.   i: integer;
  448. begin
  449.    St := '';
  450.    for i := 1 to length (S) do
  451.       if S[i] in ValidChars then
  452.          St := St + S [i];
  453.    StripMask := St;
  454. end;
  455.  
  456. procedure CutFirstDirectory(var S: TFileName);
  457. var
  458.   Root: Boolean;
  459.   P: Integer;
  460. begin
  461.   if S = '\' then S := ''
  462.   else begin
  463.     if S[1] = '\' then
  464.     begin
  465.       Root := True;
  466.       S := Copy(S, 2, 255);
  467.     end else Root := False;
  468.     if S[1] = '.' then S := Copy(S, 5, 255);
  469.     P := Pos('\',S);
  470.     if P <> 0 then S := '...\' + Copy(S, P + 1, 255)
  471.     else S := '';
  472.     if Root then S := '\' + S;
  473.   end;
  474. end;
  475.  
  476. function MinimizeName(const Filename: TFileName; Canvas: TCanvas;
  477.   MaxLen: Integer): TFileName;
  478. var
  479.   Drive: string[3];
  480.   Dir: TFileName;
  481.   Name: TFileName;
  482.   Ext: TFileName;
  483.   P: Integer;
  484. begin
  485.   Result := FileName;
  486.   Dir := ExtractFilePath(Result);
  487.   Name := ExtractFileName(Result);
  488.   P := Pos('.', Name);
  489.   if P > 0 then Name[0] := Chr(P - 1);
  490.   Ext := ExtractFileExt(Result);
  491.  
  492.   if Dir[2] = ':' then
  493.   begin
  494.     Drive := Copy(Dir, 1, 2);
  495.     Dir := Copy(Dir, 3, 255);
  496.   end else Drive := '';
  497.   while ((Dir <> '') or (Drive <> '')) and (Canvas.TextWidth(Result) > MaxLen) do
  498.   begin
  499.     if Dir = '\...\' then
  500.     begin
  501.       Drive := '';
  502.       Dir := '...\';
  503.     end else if Dir = '' then Drive := ''
  504.     else CutFirstDirectory(Dir);
  505.     Result := Drive + Dir + Name + Ext;
  506.   end;
  507. end;
  508.  
  509. end.